home *** CD-ROM | disk | FTP | other *** search
/ The Programmer Disk / The Programmer Disk (Microforum).iso / xpro / vb1 / pro24 / sorts.bas < prev    next >
BASIC Source File  |  1992-09-23  |  5KB  |  134 lines
  1.  
  2. '   SORTS.BAS
  3.  
  4. '   ***************************************************
  5. '   *   Don't forget SORTS.TXT in the global module   *
  6. '   ***************************************************
  7.  
  8. '   Being an example of an efficient in-memory sort routine.
  9. '   Contributed by Tom Dacon, for free.
  10.  
  11. '   This algorithm implements a refinement on the bubble sort which is
  12. '   referred to as a comb sort.  The comb sort has performance
  13. '   characteristics which make it nearly as fast as QuickSort with
  14. '   only minor modifications to the basic bubble sort algorithm.
  15.  
  16. '   Ref:  Byte Magazine, April 1991, "A Fast, Easy Sort",
  17. '         Stephen Lacey and Richard Box
  18.  
  19. '   The thing that's so cool about this algorithm is that it's relatively
  20. '   error-free to clone the routine for different types of data elements.
  21.  
  22. '   This implementation gets even faster for string sorting if you
  23. '   can use fixed-length strings and use the Mid$() function for
  24. '   swapping the contents.
  25.  
  26.  
  27. '   Depends on the following manifest constants
  28. '   being present in the global module.
  29. '
  30. '   Global Const FALSE, TRUE
  31. '   Global Const SORTASCENDING                 'sort-order argument
  32. '   Global Const SORTDESCENDING                'sort-order argument
  33. '   Global Const SORTIGNORECASE                'modifier for string sorts
  34.  
  35.     DefInt A-Z
  36.  
  37. Sub SortStrings (array() As String, ByVal firstIndex As Integer, ByVal lastIndex As Integer, ByVal sortKey As Integer)
  38. '
  39. '     Sort an array, or subset of an array,
  40. '     according to specified sort key.
  41. '
  42. '   Input:
  43. '           array()    - array of elements to be sorted
  44. '           firstIndex - index in array() of 1st element to be sorted
  45. '           lastIndex  - index in array() of last element to be sorted
  46. '           sortkey    - one of SORTASCENDING or SORTDESCENDING
  47. '                        optionally combined with SORTIGNORECASE
  48. '                        as in (SORTASCENDING + SORTIGNORECASE)
  49. '                        or    (SORTASCENDING Or SORTIGNORECASE)
  50. '
  51.  
  52.     Const SHRINKFACTOR = 1.3        'magic number (see article)
  53.  
  54.     Dim gap        As Integer
  55.     Dim i          As Integer
  56.     Dim ignoreCase As Integer
  57.     Dim j          As Integer
  58.     Dim nElements  As Integer
  59.     Dim order      As Integer
  60.     Dim swapThem   As Integer   'Boolean(elements not in correct order)
  61.     Dim switches   As Integer   'Boolean(any swap occurred)
  62.     Dim top        As Integer
  63.  
  64.     Dim temp       As String    'for the swap
  65.  
  66.     nElements = lastIndex - firstIndex + 1  'form count of elements to sort
  67.  
  68.     If nElements > 1 Then   'if there's anything to sort...
  69.  
  70.         ignoreCase = ((sortKey And SORTIGNORECASE) <> 0)
  71.         order = SortAndOut(sortKey, SORTIGNORECASE)
  72.  
  73.         If (order = SORTASCENDING Or order = SORTDESCENDING) Then
  74.  
  75.             gap = nElements
  76.             Do
  77.                 gap = Int(gap / SHRINKFACTOR)
  78.                 Select Case gap
  79.                 Case 0
  80.                     gap = 1
  81.                 Case 9, 10
  82.                     gap = 11
  83.                 Case Else
  84.                 End Select
  85.  
  86.                 switches = FALSE
  87.                 top = lastIndex - gap
  88.                 For i = firstIndex To top
  89.                     j = i + gap
  90.  
  91.                     Select Case order
  92.                     Case SORTASCENDING
  93.                         If ignoreCase Then
  94.                             swapThem = (UCase$(array(i)) > UCase$(array(j)))
  95.                         Else
  96.                             swapThem = (array(i) > array(j))
  97.                         End If
  98.                     Case SORTDESCENDING
  99.                         If ignoreCase Then
  100.                             swapThem = (UCase$(array(i)) < UCase$(array(j)))
  101.                         Else
  102.                             swapThem = (array(i) < array(j))
  103.                         End If
  104.                     End Select
  105.  
  106.                     '   If they're out of order, swap them.
  107.  
  108.                     If swapThem Then
  109.                         temp = array(i)
  110.                         array(i) = array(j)
  111.                         array(j) = temp
  112.                         switches = TRUE 'indicate we weren't done
  113.                     End If
  114.  
  115.                 Next i
  116.  
  117.            Loop While switches Or (gap > 1)
  118.  
  119.         End If  'a valid sort order was supplied
  120.     End If  'we have anything to sort
  121.  
  122. End Sub
  123.  
  124. Function SortAndOut (ByVal value1 As Integer, ByVal value2 As Integer) As Integer
  125. '
  126. '   And's out from the bits in <value1> whatever bits are set in <value2>
  127. '   and returns the result.
  128. '   For example, AndOut(&HFFFF, &H00FF) returns &HFF00.
  129. '
  130.    SortAndOut = (value1 And (&HFFFF Xor value2))
  131.  
  132. End Function
  133.  
  134.